home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Source Code / Peter Lewis / PNL Libraries / MyLists.p < prev    next >
Encoding:
Text File  |  1994-08-04  |  9.9 KB  |  400 lines  |  [TEXT/PJMM]
  1. unit MyLists;
  2.  
  3. interface
  4.  
  5. { Some types have been changed to avoid clashing with the list manager }
  6.     type
  7.         listHead = ^listNode;            { Was listHeadHandle }
  8.         listItem = ^listNode;            { Was listHandle }
  9.         listNode = record
  10.                 head: boolean;
  11.                 next: listItem;
  12.                 prev: listItem;
  13.                 this: handle;
  14.             end;
  15.  
  16.     var
  17.         listError: boolean;
  18.  
  19.     procedure CreateList (var l: listHead);
  20.     procedure DestroyList (var l: listHead; dispose: boolean);
  21.  
  22.     procedure ReturnHead (lh: listHead; var l: listItem);
  23.     (* <a> b c / <a> b c / <a> b c / <a> / <a> / <> *)
  24.     procedure ReturnTail (lh: listHead; var l: listItem);
  25.     (* a b c <> / a b c <> / a b c <> / a b c <> / a <> / a <> / <> *)
  26.  
  27.     procedure MoveToHead (var l: listItem);
  28.     (* <a> b c / <a> b c / <a> b c / <a> b c / <a> / <a> / <> *)
  29.     procedure MoveToTail (var l: listItem);
  30.     (* a b c <> / a b c <> / a b c <> / a b c <> / a <> / a <> / <> *)
  31.     procedure MoveToNext (var l: listItem);
  32.     (* a <b> c / a b <c> / a b c <> / error / a <> / error / error *)
  33.     procedure MoveToPrev (var l: listItem);
  34.     (* error / <a> b c / a <b> c / a b <c> / error / <a> / error *)
  35.  
  36.     function FindItem (lh: listHead; it: univ handle; var l: listItem): boolean;
  37.  
  38.     procedure AddHead (l: listHead; it: univ handle);
  39.     (* x <a> b c / x a <b> c / x a b <c> / x a b c <> / x <a> / x a <> / x <>*)
  40.     procedure AddTail (l: listHead; it: univ handle);
  41.     (* <a> b c x / a <b> c x / a b <c> x / a b c x <> / <a> x / a x <> / x <>*)
  42.     procedure AddBefore (l: listItem; it: univ handle);
  43.     (* x <a> b c / a x <b> c / a b x <c> / a b c x <> / x <a> / a x <> / x <>*)
  44.     procedure AddAfter (l: listItem; it: univ handle);
  45.     (* <a> x b c / a <b> x c / a b <c> x / error / <a> x / error / error *)
  46.  
  47.     procedure DeleteHead (l: listHead; var it: univ handle);
  48.     (* <?> b c / <b> c / b <c> / b c <> / <?> / <> / error *)
  49.     procedure DeleteTail (l: listHead; var it: univ handle);
  50.     (* <a> b / a <b> / a b <?> / a b <> / <?> / <> / error *)
  51.     procedure DeletePrev (l: listItem; var it: univ handle);
  52.     (* error / <b> c / a <c> / a b <> / error / <> / error *)
  53.     procedure DeleteNext (l: listItem; var it: univ handle);
  54.     (* <a> c / a <b> / error / error / error / error / error *)
  55.     procedure DeleteItem (var l: listItem; var it: univ handle);
  56.     (* <b> c / a <c> / a b <> / error / <> / error / error *)
  57.  
  58.     procedure FetchHead (l: listHead; var it: univ handle);
  59.     (* a / a / a / a / a / a / error  *)
  60.     procedure FetchTail (l: listHead; var it: univ handle);
  61.     (* c / c / c / c / a / a / error  *)
  62.     procedure FetchNext (l: listItem; var it: univ handle);
  63.     (* b / c / error / error / error / error / error *)
  64.     procedure FetchPrev (l: listItem; var it: univ handle);
  65.     (* error / a / b / c / error / a / error *)
  66.     procedure Fetch (l: listItem; var it: univ handle);
  67.     (* a / b / c / error / a / error / error *)
  68.  
  69.     function IsHead (l: listItem): boolean;
  70.     (* T / F / F / F / T / F / T *)
  71.     function IsTail (l: listItem): boolean;
  72.     (* F / F / F / T / F / T / T *)
  73.     function IsEmpty (l: listHead): boolean;
  74.     (* F / F / F / F / F / F / T *)
  75.  
  76.     procedure DisplayList (lh: listHead);
  77.    (* To the Text Screen *)
  78.     procedure ValidateList (lh: listHead; maxlen: longInt);
  79.     (* Check the list for validity, maxlen is the maximum valid length *)
  80.  
  81. implementation
  82.  
  83. { Internal Routines }
  84.  
  85.     procedure DestroyListPtr (var l: univ listItem);
  86.     begin
  87. {    l^^.next := nil;                These dont do any good }
  88. {    l ^ ^ . prev := nil;            cause DisposHandle }
  89. {    l  ^ ^ . this := nil;            destroys the data }
  90.         DisposPtr(Ptr(l));
  91.         l := nil;
  92.     end;
  93.  
  94.     procedure CreateListPtr (var l: univ listItem);
  95.     begin
  96.         l := listItem(NewPtr(SizeOf(listNode)));
  97.         if l = nil then begin
  98.             listError := true;
  99.             DebugStr('CreateListPtr Failed!');
  100.         end;
  101.     end;
  102.  
  103.     procedure MoveToStart (var l: univ listItem);
  104.         var
  105.             tmp: listItem;
  106.     begin
  107.         if not l^.head then begin
  108.             tmp := l;
  109.             repeat
  110.                 l := l^.next;
  111.             until (tmp = l) or l^.head;
  112.             if tmp = l then
  113.                 listError := true;
  114.         end;
  115.     end;
  116.  
  117.     procedure InsertBefore (l: univ listItem; var it: univ handle);
  118.         var
  119.             tmp: listItem;
  120.     begin
  121.         CreateListPtr(tmp);
  122.         if tmp <> nil then begin
  123.             tmp^.head := false;
  124.             tmp^.this := it;
  125.             tmp^.next := l;
  126.             tmp^.prev := l^.prev;
  127.             l^.prev^.next := tmp;
  128.             l^.prev := tmp;
  129.         end;
  130.     end;
  131.  
  132.     procedure DeleteNode (l: listItem; var it: univ handle);
  133.     begin
  134.         if l^.head then
  135.             listError := true
  136.         else begin
  137.             it := l^.this;
  138.             l^.prev^.next := l^.next;
  139.             l^.next^.prev := l^.prev;
  140.             DestroyListPtr(l);
  141.         end;
  142.     end;
  143.  
  144.     procedure FetchNode (l: listItem; var it: univ handle);
  145.     begin
  146.         if l^.head then
  147.             listError := true;
  148.         it := l^.this;
  149.     end;
  150.  
  151. { External Routines }
  152.  
  153.     procedure CreateList (var l: listHead);
  154.     begin
  155.         CreateListPtr(l);
  156.         if l <> nil then begin
  157.             l^.head := true;
  158.             l^.next := listItem(l);
  159.             l^.prev := listItem(l);
  160.             l^.this := nil;
  161.         end;
  162.     end;
  163.  
  164.     procedure DestroyList (var l: listHead; dispose: boolean);
  165.         var
  166.             tmp, tmp2: listItem;
  167.     begin
  168.         tmp := l^.next;
  169.         while tmp <> listItem(l) do begin
  170.             tmp2 := tmp;
  171.             tmp := tmp^.next;
  172.             if dispose then
  173.                 DisposHandle(tmp2^.this);
  174.             DestroyListPtr(tmp2);
  175.         end;
  176.         if dispose then
  177.             DisposHandle(l^.this);
  178.         DestroyListPtr(l);
  179.     end;
  180.  
  181.     procedure ReturnHead (lh: listHead; var l: listItem);
  182.     (* <a> b c / <a> b c / <a> b c / <a> / <a> / <> *)
  183.     begin
  184.         l := lh^.next;
  185.     end;
  186.  
  187.     procedure ReturnTail (lh: listHead; var l: listItem);
  188.     (* a b c <> / a b c <> / a b c <> / a b c <> / a <> / a <> / <> *)
  189.     begin
  190.         l := listItem(lh);
  191.     end;
  192.  
  193.     function FindItem (lh: listHead; it: univ handle; var l: listItem): boolean;
  194.     begin
  195.         l := listItem(lh)^.next;
  196.         while (not l^.head) and (it <> l^.this) do
  197.             l := l^.next;
  198.         FindItem := (not l^.head) and (it = l^.this);
  199.     end;
  200.  
  201.     procedure MoveToHead (var l: listItem);
  202.     (* <a> b c / <a> b c / <a> b c / <a> b c / <a> / <a> / <> *)
  203.     begin
  204.         MoveToStart(l);
  205.         l := l^.next;
  206.     end;
  207.  
  208.     procedure MoveToTail (var l: listItem);
  209.     (* a b c <> / a b c <> / a b c <> / a b c <> / a <> / a <> / <> *)
  210.     begin
  211.         MoveToStart(l);
  212.     end;
  213.  
  214.     procedure MoveToNext (var l: listItem);
  215.     (* a <b> c / a b <c> / a b c <> / error / a <> / error / error *)
  216.     begin
  217.         if l^.head then
  218.             listError := true
  219.         else
  220.             l := l^.next;
  221.     end;
  222.  
  223.     procedure MoveToPrev (var l: listItem);
  224.     (* error / <a> b c / a <b> c / a b <c> / error / <a> / error *)
  225.     begin
  226.         if l^.prev^.head then
  227.             listError := true
  228.         else
  229.             l := l^.prev;
  230.     end;
  231.  
  232.     procedure AddHead (l: listHead; it: univ handle);
  233.     (* x <a> b c / x a <b> c / x a b <c> / x a b c <> / x <a> / x a <> / x <>*)
  234.     begin
  235.         InsertBefore(l^.next, it);
  236.     end;
  237.  
  238.     procedure AddTail (l: listHead; it: univ handle);
  239.     (* <a> b c x / a <b> c x / a b <c> x / a b c x <> / <a> x / a x <> / x <>*)
  240.     begin
  241.         InsertBefore(l, it);
  242.     end;
  243.  
  244.     procedure AddBefore (l: listItem; it: univ handle);
  245.     (* x <a> b c / a x <b> c / a b x <c> / a b c x <> / x <a> / a x <> / x <>*)
  246.     begin
  247.         InsertBefore(l, it);
  248.     end;
  249.  
  250.     procedure AddAfter (l: listItem; it: univ handle);
  251.     (* <a> x b c / a <b> x c / a b <c> x / error / <a> x / error / error *)
  252.     begin
  253.         if l^.head then
  254.             listError := true
  255.         else
  256.             InsertBefore(l^.next, it);
  257.     end;
  258.  
  259.     procedure DeleteHead (l: listHead; var it: univ handle);
  260.     (* <?> b c / <b> c / b <c> / b c <> / <?> / <> / error *)
  261.     begin
  262.         DeleteNode(l^.next, it);
  263.     end;
  264.  
  265.     procedure DeleteTail (l: listHead; var it: univ handle);
  266.     (* <a> b / a <b> / a b <?> / a b <> / <?> / <> / error *)
  267.     begin
  268.         DeleteNode(l^.prev, it);
  269.     end;
  270.  
  271.     procedure DeletePrev (l: listItem; var it: univ handle);
  272.     (* error / <b> c / a <c> / a b <> / error / <> / error *)
  273.     begin
  274.         DeleteNode(l^.prev, it);
  275.     end;
  276.  
  277.     procedure DeleteNext (l: listItem; var it: univ handle);
  278.     (* <a> c / a <b> / error / error / error / error / error *)
  279.     begin
  280.         if l^.head then begin
  281.             listError := true;
  282.             it := nil;
  283.         end
  284.         else
  285.             DeleteNode(l^.next, it);
  286.     end;
  287.  
  288.     procedure DeleteItem (var l: listItem; var it: univ handle);
  289.     (* <b> c / a <c> / a b <> / error / <> / error / error *)
  290.         var
  291.             tmp: listItem;
  292.     begin
  293.         if l^.head then begin
  294.             listError := true;
  295.             it := nil;
  296.         end
  297.         else begin
  298.             tmp := l^.next;
  299.             DeleteNode(l, it);
  300.             l := tmp;
  301.         end;
  302.     end;
  303.  
  304.     procedure FetchHead (l: listHead; var it: univ handle);
  305.     (* a / a / a / a / a / a / error  *)
  306.     begin
  307.         FetchNode(l^.next, it);
  308.     end;
  309.  
  310.     procedure FetchTail (l: listHead; var it: univ handle);
  311.     (* c / c / c / c / a / a / error  *)
  312.     begin
  313.         FetchNode(l^.prev, it);
  314.     end;
  315.  
  316.     procedure FetchNext (l: listItem; var it: univ handle);
  317.     (* b / c / error / error / error / error / error *)
  318.     begin
  319.         if l^.head then begin
  320.             listError := true;
  321.             it := nil;
  322.         end
  323.         else
  324.             FetchNode(l^.next, it);
  325.     end;
  326.  
  327.     procedure FetchPrev (l: listItem; var it: univ handle);
  328.     (* error / a / b / c / error / a / error *)
  329.     begin
  330.         FetchNode(l^.prev, it);
  331.     end;
  332.  
  333.     procedure Fetch (l: listItem; var it: univ handle);
  334.     (* a / b / c / error / a / error / error *)
  335.     begin
  336.         FetchNode(l, it);
  337.     end;
  338.  
  339.     function IsHead (l: listItem): boolean;
  340.     (* T / F / F / F / T / F / T *)
  341.     begin
  342.         IsHead := l^.prev^.head;
  343.     end;
  344.  
  345.     function IsTail (l: listItem): boolean;
  346.     (* F / F / F / T / F / T / T *)
  347.     begin
  348.         IsTail := l^.head;
  349.     end;
  350.  
  351.     function IsEmpty (l: listHead): boolean;
  352.     (* F / F / F / F / F / F / T *)
  353.     begin
  354.         IsEmpty := l^.next = listItem(l);
  355.     end;
  356.  
  357.     procedure DisplayList (lh: listHead);
  358.         var
  359.             l: listItem;
  360.             h: handle;
  361.     begin
  362.         ShowText;
  363.         ReturnHead(lh, l);
  364.         write('(');
  365.         while not IsTail(l) do begin
  366.             Fetch(l, h);
  367.             MoveToNext(l);
  368.             write(h);
  369.             if not IsTail(l) then
  370.                 write(',');
  371.         end;
  372.         writeln('  )');
  373.     end;
  374.  
  375.     procedure ValidateList (lh: listHead; maxlen: longInt);
  376.         var
  377.             item: listItem;
  378.             count: integer;
  379.             data: handle;
  380.     begin
  381.         if lh = nil then
  382.             DebugStr('ValidateList: lh = nil');
  383.         count := 0;
  384.         ReturnHead(lh, item);
  385.         if item = nil then
  386.             DebugStr('ValidateList: first item = nil');
  387.         while not IsTail(item) do begin
  388.             Fetch(item, data);
  389.             MoveToNext(item);
  390.             if item = nil then
  391.                 DebugStr('ValidateList: list item = nil');
  392.             count := count + 1;
  393.             if count > maxlen then begin
  394.                 DebugStr('ValidateList: List too long - probably bad');
  395.                 leave;
  396.             end;
  397.         end;
  398.     end;
  399.  
  400. end.